home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / mm.el.z / mm.el
Encoding:
Text File  |  1998-05-21  |  43.5 KB  |  1,267 lines
  1. ;;; mm.el,v --- Mailcap parsing routines, and MIME handling
  2. ;; Author: wmperry
  3. ;; Created: 1996/05/28 02:46:51
  4. ;; Version: 1.96
  5. ;; Keywords: mail, news, hypermedia
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1994, 1995, 1996 by William M. Perry <wmperry@cs.indiana.edu>
  9. ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
  10. ;;;
  11. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  12. ;;;
  13. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14. ;;; it under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 2, or (at your option)
  16. ;;; any later version.
  17. ;;;
  18. ;;; GNU Emacs is distributed in the hope that it will be useful,
  19. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;;; GNU General Public License for more details.
  22. ;;;
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25. ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26. ;;; Boston, MA 02111-1307, USA.
  27. ;;;
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29. ;;; Generalized mailcap parsing and access routines
  30. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31. ;;;
  32. ;;; Data structures
  33. ;;; ---------------
  34. ;;; The mailcap structure is an assoc list of assoc lists.
  35. ;;; 1st assoc list is keyed on the major content-type
  36. ;;; 2nd assoc list is keyed on the minor content-type (which can be a regexp)
  37. ;;;
  38. ;;; Which looks like:
  39. ;;; -----------------
  40. ;;; (
  41. ;;;  ("application"
  42. ;;;   ("postscript" . <info>)
  43. ;;;  )
  44. ;;;  ("text"
  45. ;;;   ("plain" . <info>)
  46. ;;;  )
  47. ;;; )
  48. ;;;
  49. ;;; Where <info> is another assoc list of the various information
  50. ;;; related to the mailcap RFC.  This is keyed on the lowercase
  51. ;;; attribute name (viewer, test, etc).  This looks like:
  52. ;;; (("viewer" . viewerinfo)
  53. ;;;  ("test"   . testinfo)
  54. ;;;  ("xxxx"   . "string")
  55. ;;; )
  56. ;;;
  57. ;;; Where viewerinfo specifies how the content-type is viewed.  Can be
  58. ;;; a string, in which case it is run through a shell, with
  59. ;;; appropriate parameters, or a symbol, in which case the symbol is
  60. ;;; funcall'd, with the buffer as an argument.
  61. ;;;
  62. ;;; testinfo is a list of strings, or nil.  If nil, it means the
  63. ;;; viewer specified is always valid.  If it is a list of strings,
  64. ;;; these are used to determine whether a viewer passes the 'test' or
  65. ;;; not.
  66. ;;;
  67. ;;; The main interface to this code is:
  68. ;;;
  69. ;;; To set everything up:
  70. ;;;
  71. ;;;  (mm-parse-mailcaps [path])
  72. ;;;
  73. ;;;  Where PATH is a unix-style path specification (: separated list
  74. ;;;  of strings).  If PATH is nil, the environment variable MAILCAPS
  75. ;;;  will be consulted.  If there is no environment variable, then a
  76. ;;;  default list of paths is used.
  77. ;;;
  78. ;;; To retrieve the information:
  79. ;;;  (mm-mime-info st [nd] [request])
  80. ;;;
  81. ;;;  Where st and nd are positions in a buffer that contain the
  82. ;;;  content-type header information of a mail/news/whatever message.
  83. ;;;  st can optionally be a string that contains the content-type
  84. ;;;  information.
  85. ;;;
  86. ;;;  Third argument REQUEST specifies what information to return.  If
  87. ;;;  it is nil or the empty string, the viewer (second field of the
  88. ;;;  mailcap entry) will be returned.  If it is a string, then the
  89. ;;;  mailcap field corresponding to that string will be returned
  90. ;;;  (print, description, whatever).  If a number, then all the
  91. ;;;  information for this specific viewer is returned.
  92. ;;;
  93. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  94. ;;; Variables, etc
  95. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  96. (eval-and-compile
  97.   (require 'cl)
  98.   (require 'devices))
  99.  
  100. (defconst mm-version (let ((x "1.96"))
  101.                (if (string-match "Revision: \\([^ \t\n]+\\)" x)
  102.                (substring x (match-beginning 1) (match-end 1))
  103.              x))
  104.   "Version # of MM package")
  105.  
  106. (defvar mm-parse-args-syntax-table
  107.   (copy-syntax-table emacs-lisp-mode-syntax-table)
  108.   "A syntax table for parsing sgml attributes.")
  109.  
  110. (modify-syntax-entry ?' "\"" mm-parse-args-syntax-table)
  111. (modify-syntax-entry ?` "\"" mm-parse-args-syntax-table)
  112. (modify-syntax-entry ?{ "(" mm-parse-args-syntax-table)
  113. (modify-syntax-entry ?} ")" mm-parse-args-syntax-table)
  114.  
  115. (defvar mm-mime-data
  116.   '(
  117.     ("multipart"   . (
  118.               ("alternative". (("viewer" . mm-multipart-viewer)
  119.                        ("type"   . "multipart/alternative")))
  120.               ("mixed"      . (("viewer" . mm-multipart-viewer)
  121.                        ("type"   . "multipart/mixed")))
  122.               (".*"         . (("viewer" . mm-save-binary-file)
  123.                        ("type"   . "multipart/*")))
  124.               )
  125.      )
  126.     ("application" . (
  127.               ("x-x509-ca-cert" . (("viewer" . ssl-view-site-cert)
  128.                        ("test" . (fboundp 'ssl-view-site-cert))
  129.                        ("type" . "application/x-x509-ca-cert")))
  130.               ("x-x509-user-cert" . (("viewer" . ssl-view-user-cert)
  131.                          ("test" . (fboundp 'ssl-view-user-cert))
  132.                          ("type" . "application/x-x509-user-cert")))
  133.               ("octet-stream" . (("viewer" . mm-save-binary-file)
  134.                      ("type" ."application/octet-stream")))
  135.               ("dvi"        . (("viewer" . "open %s")
  136.                        ("type"   . "application/dvi")
  137.                        ("test"   . (eq (device-type) 'ns))))
  138.               ("dvi"        . (("viewer" . "xdvi %s")
  139.                        ("test"   . (eq (device-type) 'x))
  140.                        ("needsx11")
  141.                        ("type"   . "application/dvi")))
  142.               ("dvi"        . (("viewer" . "dvitty %s")
  143.                        ("test"   . (not (getenv "DISPLAY")))
  144.                        ("type"   . "application/dvi")))
  145.               ("emacs-lisp" . (("viewer" . mm-maybe-eval)
  146.                        ("type"   . "application/emacs-lisp")))
  147. ;              ("x-tar"      . (("viewer" . tar-mode)
  148. ;                       ("test"   . (fboundp 'tar-mode))
  149. ;                       ("type"   . "application/x-tar")))
  150.               ("x-tar"      . (("viewer" . mm-save-binary-file)
  151.                        ("type"   . "application/x-tar")))
  152.               ("x-latex"    . (("viewer" . tex-mode)
  153.                        ("test"   . (fboundp 'tex-mode))
  154.                        ("type"   . "application/x-latex")))
  155.               ("x-tex"      . (("viewer" . tex-mode)
  156.                        ("test"   . (fboundp 'tex-mode))
  157.                        ("type"   . "application/x-tex")))
  158.               ("latex"      . (("viewer" . tex-mode)
  159.                        ("test"   . (fboundp 'tex-mode))
  160.                        ("type"   . "application/latex")))
  161.               ("tex"        . (("viewer" . tex-mode)
  162.                        ("test"   . (fboundp 'tex-mode))
  163.                        ("type"   . "application/tex")))
  164.               ("texinfo"    . (("viewer" . texinfo-mode)
  165.                        ("test"   . (fboundp 'texinfo-mode))
  166.                        ("type"   . "application/tex")))
  167.                ("zip"        . (("viewer" . mm-save-binary-file)
  168.                         ("type"   . "application/zip")
  169.                         ("copiousoutput")))
  170.               ("pdf"        . (("viewer" . "acroread %s")
  171.                        ("type"   . "application/pdf")))
  172.               ("postscript" . (("viewer" . "open %s")
  173.                        ("type"   . "application/postscript")
  174.                        ("test"   . (eq (device-type) 'ns))))
  175.               ("postscript" . (("viewer" . "ghostview %s")
  176.                        ("type" . "application/postscript")
  177.                        ("test"   . (eq (device-type) 'x))
  178.                        ("needsx11")))
  179.               ("postscript" . (("viewer" . "ps2ascii %s")
  180.                        ("type" . "application/postscript")
  181.                        ("test" . (not (getenv "DISPLAY")))
  182.                        ("copiousoutput")))
  183.               ))
  184.     ("audio"       . (
  185.               ("x-mpeg" . (("viewer" . "maplay %s")
  186.                    ("type"   . "audio/x-mpeg")))
  187.               (".*" . (("viewer" . mm-play-sound-file)
  188.                    ("test"   . (or (featurep 'nas-sound)
  189.                            (featurep 'native-sound)))
  190.                    ("type"   . "audio/*")))
  191.               (".*" . (("viewer" . "showaudio")
  192.                    ("type"   . "audio/*")))
  193.               ))
  194.     ("message"     . (
  195.               ("rfc-*822" . (("viewer" . vm-mode)
  196.                      ("test"   . (fboundp 'vm-mode))
  197.                      ("type"   . "message/rfc-822")))
  198.               ("rfc-*822" . (("viewer" . w3-mode)
  199.                      ("test"   . (fboundp 'w3-mode))
  200.                      ("type"   . "message/rfc-822")))
  201.               ("rfc-*822" . (("viewer" . view-mode)
  202.                      ("test"   . (fboundp 'view-mode))
  203.                      ("type"   . "message/rfc-822")))
  204.               ("rfc-*822" . (("viewer" . fundamental-mode)
  205.                      ("type"   . "message/rfc-822")))
  206.               ))
  207.     ("image"       . (
  208.               ("x-xwd" . (("viewer"  . "xwud -in %s")
  209.                   ("type"    . "image/x-xwd")
  210.                   ("compose" . "xwd -frame > %s")
  211.                   ("test"    . (eq (device-type) 'x))
  212.                   ("needsx11")))
  213.               ("x11-dump" . (("viewer" . "xwud -in %s")
  214.                      ("type" . "image/x-xwd")
  215.                        ("compose" . "xwd -frame > %s")
  216.                      ("test"   . (eq (device-type) 'x))
  217.                      ("needsx11")))
  218.               ("windowdump" . (("viewer" . "xwud -in %s")
  219.                        ("type" . "image/x-xwd")
  220.                            ("compose" . "xwd -frame > %s")
  221.                        ("test"   . (eq (device-type) 'x))
  222.                        ("needsx11")))
  223.               (".*" . (("viewer" . "open %s")
  224.                    ("type"   . "image/*")
  225.                    ("test"   . (eq (device-type) 'ns))))
  226.               (".*" . (("viewer" . "xv -perfect %s")
  227.                    ("type" . "image/*")
  228.                    ("test"   . (eq (device-type) 'x))
  229.                    ("needsx11")))
  230.               ))
  231.     ("text"        . (
  232.               ("plain" . (("viewer"  . w3-mode)
  233.                   ("test"    . (fboundp 'w3-mode))
  234.                   ("type"    . "text/plain")))
  235.               ("plain" . (("viewer"  . view-mode)
  236.                   ("test"    . (fboundp 'view-mode))
  237.                   ("type"    . "text/plain")))
  238.               ("plain" . (("viewer"  . fundamental-mode)
  239.                   ("type"    . "text/plain")))
  240.               ("enriched" . (("viewer" . enriched-decode-region)
  241.                      ("test"   . (fboundp
  242.                           'enriched-decode-region))
  243.                      ("type"   . "text/enriched")))
  244.               ("html"  . (("viewer" . w3-prepare-buffer)
  245.                   ("test"   . (fboundp 'w3-prepare-buffer))
  246.                   ("type"   . "text/html")))
  247.               ))
  248.     ("video"       . (
  249.               ("mpeg" . (("viewer" . "mpeg_play %s")
  250.                  ("type"   . "video/mpeg")
  251.                  ("test"   . (eq (device-type) 'x))
  252.                  ("needsx11")))
  253.               ))
  254.     ("x-world"     . (
  255.               ("x-vrml" . (("viewer"  . "webspace -remote %s -URL %u")
  256.                    ("type"    . "x-world/x-vrml")
  257.                    ("description"
  258.                     "VRML document")))))
  259.     ("archive"     . (
  260.               ("tar"  . (("viewer" . tar-mode)
  261.                  ("type" . "archive/tar")
  262.                  ("test" . (fboundp 'tar-mode))))
  263.               ))
  264.     )
  265.   "*The mailcap structure is an assoc list of assoc lists.
  266. 1st assoc list is keyed on the major content-type
  267. 2nd assoc list is keyed on the minor content-type (which can be a regexp)
  268.  
  269. Which looks like:
  270. -----------------
  271. (
  272.  (\"application\"
  273.   (\"postscript\" . <info>)
  274.  )
  275.  (\"text\"
  276.   (\"plain\" . <info>)
  277.  )
  278. )
  279.  
  280. Where <info> is another assoc list of the various information
  281. related to the mailcap RFC.  This is keyed on the lowercase
  282. attribute name (viewer, test, etc).  This looks like:
  283. ((\"viewer\" . viewerinfo)
  284.  (\"test\"   . testinfo)
  285.  (\"xxxx\"   . \"string\")
  286. )
  287.  
  288. Where viewerinfo specifies how the content-type is viewed.  Can be
  289. a string, in which case it is run through a shell, with
  290. appropriate parameters, or a symbol, in which case the symbol is
  291. funcall'd, with the buffer as an argument.
  292.  
  293. testinfo is a list of strings, or nil.  If nil, it means the
  294. viewer specified is always valid.  If it is a list of strings,
  295. these are used to determine whether a viewer passes the 'test' or
  296. not.")
  297.  
  298. (defvar mm-content-transfer-encodings
  299.   '(("base64"     . base64-decode-region)
  300.     ("7bit"       . ignore)
  301.     ("8bit"       . ignore)
  302.     ("binary"     . ignore)
  303.     ("x-compress" . ("uncompress" "-c"))
  304.     ("x-gzip"     . ("gzip" "-dc"))
  305.     ("compress"   . ("uncompress" "-c"))
  306.     ("gzip"       . ("gzip" "-dc"))
  307.     ("x-hqx"      . ("mcvert" "-P" "-s" "-S"))
  308.     ("quoted-printable" . mm-decode-quoted-printable)
  309.     )
  310.   "*An assoc list of content-transfer-encodings and how to decode them.")
  311.  
  312. (defvar mm-download-directory nil
  313.   "*Where downloaded files should go by default.")
  314.  
  315. (defvar mm-temporary-directory (or (getenv "TMPDIR") "/tmp")
  316.   "*Where temporary files go.")
  317.  
  318.  
  319. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  320. ;;; A few things from w3 and url, just in case this is used without them
  321. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  322.  
  323. (defun mm-generate-unique-filename (&optional fmt)
  324.   "Generate a unique filename in mm-temporary-directory"
  325.   (if (not fmt)
  326.       (let ((base (format "mm-tmp.%d" (user-real-uid)))
  327.         (fname "")
  328.         (x 0))
  329.     (setq fname (format "%s%d" base x))
  330.     (while (file-exists-p
  331.         (expand-file-name fname mm-temporary-directory))
  332.       (setq x (1+ x)
  333.         fname (concat base (int-to-string x))))
  334.     (expand-file-name fname mm-temporary-directory))
  335.     (let ((base (concat "mm" (int-to-string (user-real-uid))))
  336.       (fname "")
  337.       (x 0))
  338.       (setq fname (format fmt (concat base (int-to-string x))))
  339.       (while (file-exists-p
  340.           (expand-file-name fname mm-temporary-directory))
  341.     (setq x (1+ x)
  342.           fname (format fmt (concat base (int-to-string x)))))
  343.       (expand-file-name fname mm-temporary-directory))))
  344.  
  345. (if (and (fboundp 'copy-tree)
  346.      (subrp (symbol-function 'copy-tree)))
  347.     (fset 'mm-copy-tree 'copy-tree)
  348.   (defun mm-copy-tree (tree)
  349.     (if (consp tree)
  350.     (cons (mm-copy-tree (car tree))
  351.           (mm-copy-tree (cdr tree)))
  352.       (if (vectorp tree)
  353.       (let* ((new (copy-sequence tree))
  354.          (i (1- (length new))))
  355.         (while (>= i 0)
  356.           (aset new i (mm-copy-tree (aref new i)))
  357.           (setq i (1- i)))
  358.         new)
  359.     tree))))
  360.  
  361. (require 'mule-sysdp)
  362.  
  363. (if (not (fboundp 'w3-save-binary-file))
  364.     (defun mm-save-binary-file ()
  365.       ;; Ok, this is truly fucked.  In XEmacs, if you use the mouse to select
  366.       ;; a URL that gets saved via this function, read-file-name will pop up a
  367.       ;; dialog box for file selection.  For some reason which buffer we are in
  368.       ;; gets royally screwed (even with save-excursions and the whole nine
  369.       ;; yards).  SO, we just keep the old buffer name around and away we go.
  370.       (let ((old-buff (current-buffer))
  371.         (file (read-file-name "Filename to save as: "
  372.                   (or mm-download-directory "~/")
  373.                   (file-name-nondirectory (url-view-url t))
  374.                   nil
  375.                   (file-name-nondirectory (url-view-url t))))
  376.         (require-final-newline nil))
  377.     (set-buffer old-buff)
  378.     (mule-write-region-no-coding-system (point-min) (point-max) file)
  379.     (kill-buffer (current-buffer))))
  380.   (fset 'mm-save-binary-file 'w3-save-binary-file))
  381.  
  382. (defun mm-maybe-eval ()
  383.   "Maybe evaluate a buffer of emacs lisp code"
  384.   (if (yes-or-no-p "This is emacs-lisp code, evaluate it? ")
  385.       (eval-buffer (current-buffer))
  386.     (emacs-lisp-mode)))
  387.  
  388.  
  389. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  390. ;;; The mailcap parser
  391. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  392. (defun mm-viewer-unescape (format &optional filename url)
  393.   (save-excursion
  394.     (set-buffer (get-buffer-create " *mm-parse*"))
  395.     (erase-buffer)
  396.     (insert format)
  397.     (goto-char (point-min))
  398.     (while (re-search-forward "%\\(.\\)" nil t)
  399.        (let ((escape (aref (match-string 1) 0)))
  400.      (replace-match "" t t)
  401.      (case escape
  402.        (?% (insert "%"))
  403.        (?s (insert (or filename "\"\"")))
  404.        (?u (insert (or url "\"\""))))))
  405.     (buffer-string)))
  406.  
  407. (defun mm-in-assoc (elt list)
  408.   ;; Check to see if ELT matches any of the regexps in the car elements of LIST
  409.   (let (rslt)
  410.     (while (and list (not rslt))
  411.       (and (car (car list))
  412.        (string-match (car (car list)) elt)
  413.        (setq rslt (car list)))
  414.       (setq list (cdr list)))
  415.     rslt))
  416.  
  417. (defun mm-replace-regexp (regexp to-string)
  418.   ;; Quiet replace-regexp.
  419.   (goto-char (point-min))
  420.   (while (re-search-forward regexp nil t)
  421.     (replace-match to-string t nil)))
  422.  
  423. (defun mm-parse-mailcaps (&optional path)
  424.   ;; Parse out all the mailcaps specified in a unix-style path string PATH
  425.   (cond
  426.    (path nil)
  427.    ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS")))
  428.    ((memq system-type '(ms-dos ms-windows windows-nt))
  429.     (setq path (mapconcat 'expand-file-name '("~/mail.cap" "~/etc/mail.cap")
  430.               ";")))
  431.    (t (setq path (mapconcat 'expand-file-name
  432.                 '("~/.mailcap"
  433.                   "/etc/mailcap:/usr/etc/mailcap"
  434.                   "/usr/local/etc/mailcap") ":"))))
  435.   (let ((fnames (reverse
  436.          (mm-string-to-tokens path
  437.                       (if (memq system-type
  438.                         '(ms-dos ms-windows windows-nt))
  439.                       ?;
  440.                     ?:))))
  441.     fname)
  442.     (while fnames
  443.       (setq fname (car fnames))
  444.       (if (and (file-exists-p fname) (file-readable-p fname))
  445.       (mm-parse-mailcap (car fnames)))
  446.       (setq fnames (cdr fnames)))))
  447.  
  448. (defun mm-parse-mailcap (fname)
  449.   ;; Parse out the mailcap file specified by FNAME
  450.   (let (major                ; The major mime type (image/audio/etc)
  451.     minor                ; The minor mime type (gif, basic, etc)
  452.     save-pos            ; Misc saved positions used in parsing
  453.     viewer                ; How to view this mime type
  454.     info                ; Misc info about this mime type
  455.     )
  456.     (save-excursion
  457.       (set-buffer (get-buffer-create " *mailcap*"))
  458.       (erase-buffer)
  459.       (insert-file-contents fname)
  460.       (set-syntax-table mm-parse-args-syntax-table)
  461.       (mm-replace-regexp "#.*" "")             ; Remove all comments
  462.       (mm-replace-regexp "\n+" "\n")         ; And blank lines
  463.       (mm-replace-regexp "\\\\[ \t\n]+" " ") ; And collapse spaces
  464.       (mm-replace-regexp (concat (regexp-quote "\\") "[ \t]*\n") "")
  465.       (goto-char (point-max))
  466.       (skip-chars-backward " \t\n")
  467.       (delete-region (point) (point-max))
  468.       (goto-char (point-min))
  469.       (while (not (eobp))
  470.     (skip-chars-forward " \t\n")
  471.     (setq save-pos (point)
  472.           info nil)
  473.     (skip-chars-forward "^/;")
  474.     (downcase-region save-pos (point))
  475.     (setq major (buffer-substring save-pos (point)))
  476.     (skip-chars-forward "/ \t\n")
  477.     (setq save-pos (point))
  478.     (skip-chars-forward "^;")
  479.     (downcase-region save-pos (point))
  480.     (setq minor
  481.           (cond
  482.            ((= ?* (or (char-after save-pos) 0)) ".*")
  483.            ((= (point) save-pos) ".*")
  484.            (t (buffer-substring save-pos (point)))))
  485.     (skip-chars-forward "; \t\n")
  486.     ;;; Got the major/minor chunks, now for the viewers/etc
  487.     ;;; The first item _must_ be a viewer, according to the
  488.     ;;; RFC for mailcap files (#1343)
  489.     (skip-chars-forward "; \t\n")
  490.     (setq save-pos (point))
  491.     (skip-chars-forward "^;\n")
  492.     (if (= (or (char-after save-pos) 0) ?')
  493.         (setq viewer (progn
  494.                (narrow-to-region (1+ save-pos) (point))
  495.                (goto-char (point-min))
  496.                (prog1
  497.                    (read (current-buffer))
  498.                  (goto-char (point-max))
  499.                  (widen))))
  500.       (setq viewer (buffer-substring save-pos (point))))
  501.     (setq save-pos (point))
  502.     (end-of-line)
  503.     (setq info (nconc (list (cons "viewer" viewer)
  504.                 (cons "type" (concat major "/"
  505.                              (if (string= minor ".*")
  506.                              "*" minor))))
  507.               (mm-parse-mailcap-extras save-pos (point))))
  508.     (mm-mailcap-entry-passes-test info)
  509.     (mm-add-mailcap-entry major minor info)))))
  510.  
  511. (defun mm-parse-mailcap-extras (st nd)
  512.   ;; Grab all the extra stuff from a mailcap entry
  513.   (let (
  514.     name                ; From name=
  515.     value                ; its value
  516.     results                ; Assoc list of results
  517.     name-pos            ; Start of XXXX= position
  518.     val-pos                ; Start of value position
  519.     done                ; Found end of \'d ;s?
  520.     )
  521.     (save-restriction
  522.       (narrow-to-region st nd)
  523.       (goto-char (point-min))
  524.       (skip-chars-forward " \n\t;")
  525.       (while (not (eobp))
  526.     (setq done nil)
  527.     (skip-chars-forward " \";\n\t")
  528.     (setq name-pos (point))
  529.     (skip-chars-forward "^ \n\t=")
  530.     (downcase-region name-pos (point))
  531.     (setq name (buffer-substring name-pos (point)))
  532.     (skip-chars-forward " \t\n")
  533.     (if (/= (or (char-after (point)) 0)  ?=) ; There is no value
  534.         (setq value nil)
  535.       (skip-chars-forward " \t\n=")
  536.       (setq val-pos (point))
  537.       (if (memq (char-after val-pos) '(?\" ?'))
  538.           (progn
  539.         (setq val-pos (1+ val-pos))
  540.         (condition-case nil
  541.             (progn
  542.               (forward-sexp 1)
  543.               (backward-char 1))
  544.           (error (goto-char (point-max)))))
  545.         (while (not done)
  546.           (skip-chars-forward "^;")
  547.           (if (= (or (char-after (1- (point))) 0) ?\\ )
  548.           (progn
  549.             (subst-char-in-region (1- (point)) (point) ?\\ ? )
  550.             (skip-chars-forward ";"))
  551.         (setq done t))))
  552.       (setq    value (buffer-substring val-pos (point))))
  553.     (setq results (cons (cons name value) results)))
  554.       results)))  
  555.  
  556. (defun mm-string-to-tokens (str &optional delim)
  557.   "Return a list of words from the string STR"
  558.   (setq delim (or delim ? ))
  559.   (let (results y)
  560.     (mapcar
  561.      (function
  562.       (lambda (x)
  563.     (cond
  564.      ((and (= x delim) y) (setq results (cons y results) y nil))
  565.      ((/= x delim) (setq y (concat y (char-to-string x))))
  566.      (t nil)))) str)
  567.     (nreverse (cons y results))))
  568.  
  569. (defun mm-mailcap-entry-passes-test (info)
  570.   ;; Return t iff a mailcap entry passes its test clause or no test
  571.   ;; clause is present.
  572.   (let (status                ; Call-process-regions return value
  573.     (test (assoc "test" info)); The test clause
  574.     )
  575.     (setq status (and test (mm-string-to-tokens (cdr test))))
  576.     (if (and (assoc "needsx11" info) (not (getenv "DISPLAY")))
  577.     (setq status nil)
  578.       (cond
  579.        ((and (equal (nth 0 status) "test")
  580.          (equal (nth 1 status) "-n")
  581.          (or (equal (nth 2 status) "$DISPLAY")
  582.          (equal (nth 2 status) "\"$DISPLAY\"")))
  583.     (setq status (if (getenv "DISPLAY") t nil)))
  584.        ((and (equal (nth 0 status) "test")
  585.          (equal (nth 1 status) "-z")
  586.          (or (equal (nth 2 status) "$DISPLAY")
  587.          (equal (nth 2 status) "\"$DISPLAY\"")))
  588.     (setq status (if (getenv "DISPLAY") nil t)))
  589.        (test nil)
  590.        (t nil)))
  591.     (and test (listp test) (setcdr test status))))
  592.  
  593. (defun mm-parse-args (st &optional nd nodowncase)
  594.   ;; Return an assoc list of attribute/value pairs from an RFC822-type string
  595.   (let (
  596.     name                ; From name=
  597.     value                ; its value
  598.     results                ; Assoc list of results
  599.     name-pos            ; Start of XXXX= position
  600.     val-pos                ; Start of value position
  601.     )
  602.     (save-excursion
  603.       (if (stringp st)
  604.       (progn
  605.         (set-buffer (get-buffer-create " *mm-temp*"))
  606.         (set-syntax-table mm-parse-args-syntax-table)
  607.         (erase-buffer)
  608.         (insert st)
  609.         (setq st (point-min)
  610.           nd (point-max)))
  611.     (set-syntax-table mm-parse-args-syntax-table))
  612.       (save-restriction
  613.     (narrow-to-region st nd)
  614.     (goto-char (point-min))
  615.     (while (not (eobp))
  616.       (skip-chars-forward "; \n\t")
  617.       (setq name-pos (point))
  618.       (skip-chars-forward "^ \n\t=;")
  619.       (if (not nodowncase)
  620.           (downcase-region name-pos (point)))
  621.       (setq name (buffer-substring name-pos (point)))
  622.       (skip-chars-forward " \t\n")
  623.       (if (/= (or (char-after (point)) 0)  ?=) ; There is no value
  624.           (setq value nil)
  625.         (skip-chars-forward " \t\n=")
  626.         (setq val-pos (point)
  627.           value
  628.           (cond
  629.            ((or (= (or (char-after val-pos) 0) ?\")
  630.             (= (or (char-after val-pos) 0) ?'))
  631.             (buffer-substring (1+ val-pos)
  632.                       (condition-case ()
  633.                       (prog2
  634.                           (forward-sexp 1)
  635.                           (1- (point))
  636.                         (skip-chars-forward "\""))
  637.                     (error
  638.                      (skip-chars-forward "^ \t\n")
  639.                      (point)))))
  640.            (t
  641.             (buffer-substring val-pos
  642.                       (progn
  643.                     (skip-chars-forward "^;")
  644.                     (skip-chars-backward " \t")
  645.                     (point)))))))
  646.       (setq results (cons (cons name value) results))
  647.       (skip-chars-forward "; \n\t"))
  648.     results))))
  649.  
  650. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  651. ;;; The action routines.
  652. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  653. (defun mm-possible-viewers (major minor)
  654.   ;; Return a list of possible viewers from MAJOR for minor type MINOR
  655.   (let ((exact '())
  656.     (wildcard '()))
  657.     (while major
  658.       (cond
  659.        ((equal (car (car major)) minor)
  660.     (setq exact (cons (cdr (car major)) exact)))
  661.        ((string-match (car (car major)) minor)
  662.     (setq wildcard (cons (cdr (car major)) wildcard))))
  663.       (setq major (cdr major)))
  664.     (nconc (nreverse exact) (nreverse wildcard))))
  665.  
  666. (defun mm-unescape-mime-test (test type-info)
  667.   (let ((buff (get-buffer-create " *unescape*"))
  668.     save-pos save-chr subst)
  669.     (cond
  670.      ((symbolp test) test)
  671.      ((and (listp test) (symbolp (car test))) test)
  672.      ((or (stringp test)
  673.       (and (listp test) (stringp (car test))
  674.            (setq test (mapconcat 'identity test " "))))
  675.       (save-excursion
  676.     (set-buffer buff)
  677.     (erase-buffer)
  678.     (insert test)
  679.     (goto-char (point-min))
  680.     (while (not (eobp))
  681.       (skip-chars-forward "^%")
  682.       (if (/= (- (point)
  683.              (progn (skip-chars-backward "\\\\")
  684.                 (point)))
  685.           0) ; It is an escaped %
  686.           (progn
  687.         (delete-char 1)
  688.         (skip-chars-forward "%."))
  689.         (setq save-pos (point))
  690.         (skip-chars-forward "%")
  691.         (setq save-chr (char-after (point)))
  692.         (cond
  693.          ((null save-chr) nil)
  694.          ((= save-chr ?t)
  695.           (delete-region save-pos (progn (forward-char 1) (point)))
  696.           (insert (or (cdr (assoc "type" type-info)) "\"\"")))
  697.          ((= save-chr ?M)
  698.           (delete-region save-pos (progn (forward-char 1) (point)))
  699.           (insert "\"\""))
  700.          ((= save-chr ?n)
  701.           (delete-region save-pos (progn (forward-char 1) (point)))
  702.           (insert "\"\""))
  703.          ((= save-chr ?F)
  704.           (delete-region save-pos (progn (forward-char 1) (point)))
  705.           (insert "\"\""))
  706.          ((= save-chr ?{)
  707.           (forward-char 1)
  708.           (skip-chars-forward "^}")
  709.           (downcase-region (+ 2 save-pos) (point))
  710.           (setq subst (buffer-substring (+ 2 save-pos) (point)))
  711.           (delete-region save-pos (1+ (point)))
  712.           (insert (or (cdr (assoc subst type-info)) "\"\"")))
  713.          (t nil))))
  714.     (buffer-string)))
  715.      (t (error "Bad value to mm-unescape-mime-test. %s" test)))))
  716.  
  717. (defun mm-viewer-passes-test (viewer-info type-info)
  718.   ;; Return non-nil iff the viewer specified by VIEWER-INFO passes its
  719.   ;; test clause (if any).
  720.   (let* ((test-info   (assoc "test"   viewer-info))
  721.      (test (cdr test-info))
  722.      (viewer (cdr (assoc "viewer" viewer-info)))
  723.      (default-directory (expand-file-name "~/"))
  724.      status
  725.      parsed-test
  726.     )
  727.     (cond
  728.      ((not test-info) t)        ; No test clause
  729.      ((not test) nil)            ; Already failed test
  730.      ((eq test t) t)            ; Already passed test
  731.      ((and (symbolp test)        ; Lisp function as test
  732.        (fboundp test))
  733.       (funcall test type-info))
  734.      ((and (symbolp test)        ; Lisp variable as test
  735.        (boundp test))
  736.       (symbol-value test))
  737.      ((and (listp test)            ; List to be eval'd
  738.        (symbolp (car test)))
  739.       (eval test))
  740.      (t
  741.       (setq test (mm-unescape-mime-test test type-info)
  742.         test (list shell-file-name nil nil nil shell-command-switch test)
  743.         status (apply 'call-process test))
  744.       (= 0 status)))))
  745.  
  746. (defun mm-add-mailcap-entry (major minor info)
  747.   (let ((old-major (assoc major mm-mime-data)))
  748.     (if (null old-major)        ; New major area
  749.     (setq mm-mime-data
  750.           (cons (cons major (list (cons minor info)))
  751.             mm-mime-data))
  752.       (let ((cur-minor (assoc minor old-major)))
  753.     (cond
  754.      ((or (null cur-minor)        ; New minor area, or
  755.           (assoc "test" info))    ; Has a test, insert at beginning
  756.       (setcdr old-major (cons (cons minor info) (cdr old-major))))
  757.      ((and (not (assoc "test" info)); No test info, replace completely
  758.            (not (assoc "test" cur-minor)))
  759.       (setcdr cur-minor info))
  760.      (t
  761.       (setcdr old-major (cons (cons minor info) (cdr old-major)))))))))
  762.  
  763.  
  764. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  765. ;;; The main whabbo
  766. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  767. (defun mm-viewer-lessp (x y)
  768.   ;; Return t iff viewer X is more desirable than viewer Y
  769.   (let ((x-wild (string-match "[*?]" (or (cdr-safe (assoc "type" x)) "")))
  770.     (y-wild (string-match "[*?]" (or (cdr-safe (assoc "type" y)) "")))
  771.     (x-lisp (not (stringp (or (cdr-safe (assoc "viewer" x)) ""))))
  772.     (y-lisp (not (stringp (or (cdr-safe (assoc "viewer" y)) "")))))
  773.     (cond
  774.      ((and x-lisp (not y-lisp))
  775.       t)
  776.      ((and (not y-lisp) x-wild (not y-wild))
  777.       t)
  778.      ((and (not x-wild) y-wild)
  779.       t)
  780.      (t nil))))
  781.  
  782. (defun mm-mime-info (st &optional nd request)
  783.   "Get the mime viewer command for HEADERLINE, return nil if none found.
  784. Expects a complete content-type header line as its argument.  This can
  785. be simple like text/html, or complex like text/plain; charset=blah; foo=bar
  786.  
  787. Third argument REQUEST specifies what information to return.  If it is
  788. nil or the empty string, the viewer (second field of the mailcap
  789. entry) will be returned.  If it is a string, then the mailcap field
  790. corresponding to that string will be returned (print, description,
  791. whatever).  If a number, then all the information for this specific
  792. viewer is returned."
  793.   (let (
  794.     major                ; Major encoding (text, etc)
  795.     minor                ; Minor encoding (html, etc)
  796.     info                ; Other info
  797.     save-pos            ; Misc. position during parse
  798.     major-info            ; (assoc major mm-mime-data)
  799.     minor-info            ; (assoc minor major-info)
  800.     test                ; current test proc.
  801.     viewers                ; Possible viewers
  802.     passed                ; Viewers that passed the test
  803.     viewer                ; The one and only viewer
  804.     )
  805.     (save-excursion
  806.       (cond
  807.        ((null st)
  808.     (set-buffer (get-buffer-create " *mimeparse*"))
  809.     (erase-buffer)
  810.     (insert "text/plain")
  811.     (setq st (point-min)))
  812.        ((stringp st)
  813.     (set-buffer (get-buffer-create " *mimeparse*"))
  814.     (erase-buffer)
  815.     (insert st)
  816.     (setq st (point-min)))
  817.        ((null nd)
  818.     (narrow-to-region st (progn (goto-char st) (end-of-line) (point))))
  819.        (t (narrow-to-region st nd)))
  820.       (goto-char st)
  821.       (skip-chars-forward ": \t\n")
  822.       (buffer-enable-undo)
  823.       (setq viewer
  824.         (catch 'mm-exit
  825.           (setq save-pos (point))
  826.           (skip-chars-forward "^/")
  827.           (downcase-region save-pos (point))
  828.           (setq major (buffer-substring save-pos (point)))
  829.           (if (not (setq major-info (cdr (assoc major mm-mime-data))))
  830.           (throw 'mm-exit nil))
  831.           (skip-chars-forward "/ \t\n")
  832.           (setq save-pos (point))
  833.           (skip-chars-forward "^ \t\n;")
  834.           (downcase-region save-pos (point))
  835.           (setq minor (buffer-substring save-pos (point)))
  836.           (if (not
  837.            (setq viewers (mm-possible-viewers major-info minor)))
  838.           (throw 'mm-exit nil))
  839.           (skip-chars-forward "; \t")
  840.           (if (eolp)
  841.           nil                ; No qualifiers
  842.         (setq save-pos (point))
  843.         (end-of-line)
  844.         (setq info (mm-parse-args save-pos (point)))
  845.         )
  846.           (while viewers
  847.         (if (mm-viewer-passes-test (car viewers) info)
  848.             (setq passed (cons (car viewers) passed)))
  849.         (setq viewers (cdr viewers)))
  850.           (setq passed (sort (nreverse passed) 'mm-viewer-lessp))
  851.           (car passed)))
  852.       (if (and (stringp (cdr (assoc "viewer" viewer)))
  853.            passed)
  854.       (setq viewer (car passed)))
  855.       (widen)
  856.       (cond
  857.        ((and (null viewer) (not (equal major "default")))
  858.     (mm-mime-info "default" nil request))
  859.        ((or (null request) (equal request ""))
  860.     (mm-unescape-mime-test (cdr (assoc "viewer" viewer)) info))
  861.        ((stringp request)
  862.     (if (or (string= request "test") (string= request "viewer"))
  863.         (mm-unescape-mime-test (cdr-safe (assoc request viewer)) info)))
  864.        (t
  865.     ;; MUST make a copy *sigh*, else we modify mm-mime-data
  866.     (setq viewer (mm-copy-tree viewer))
  867.     (let ((view (assoc "viewer" viewer))
  868.           (test (assoc "test" viewer)))
  869.       (if view (setcdr view (mm-unescape-mime-test (cdr view) info)))
  870.       (if test (setcdr test (mm-unescape-mime-test (cdr test) info))))
  871.     viewer)))))
  872.  
  873.  
  874. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  875. ;;; Experimental MIME-types parsing
  876. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  877. (defvar mm-mime-extensions
  878.   '(
  879.     (""          . "text/plain")
  880.     (".abs"      . "audio/x-mpeg")
  881.     (".aif"      . "audio/aiff")
  882.     (".aifc"     . "audio/aiff")
  883.     (".aiff"     . "audio/aiff")
  884.     (".ano"      . "application/x-annotator")
  885.     (".au"       . "audio/ulaw")
  886.     (".avi"      . "video/x-msvideo")
  887.     (".bcpio"    . "application/x-bcpio")
  888.     (".bin"      . "application/octet-stream")
  889.     (".cdf"      . "application/x-netcdr")
  890.     (".cpio"     . "application/x-cpio")
  891.     (".csh"      . "application/x-csh")
  892.     (".dvi"      . "application/x-dvi")
  893.     (".el"       . "application/emacs-lisp")
  894.     (".eps"      . "application/postscript")
  895.     (".etx"      . "text/x-setext")
  896.     (".exe"      . "application/octet-stream")
  897.     (".fax"      . "image/x-fax")
  898.     (".gif"      . "image/gif")
  899.     (".hdf"      . "application/x-hdf")
  900.     (".hqx"      . "application/mac-binhex40")
  901.     (".htm"      . "text/html")
  902.     (".html"     . "text/html")
  903.     (".icon"     . "image/x-icon")
  904.     (".ief"      . "image/ief")
  905.     (".jpg"      . "image/jpeg")
  906.     (".macp"     . "image/x-macpaint")
  907.     (".man"      . "application/x-troff-man")
  908.     (".me"       . "application/x-troff-me")
  909.     (".mif"      . "application/mif")
  910.     (".mov"      . "video/quicktime")
  911.     (".movie"    . "video/x-sgi-movie")
  912.     (".mp2"      . "audio/x-mpeg")
  913.     (".mp2a"     . "audio/x-mpeg2")
  914.     (".mpa"      . "audio/x-mpeg")
  915.     (".mpa2"     . "audio/x-mpeg2")
  916.     (".mpe"      . "video/mpeg")
  917.     (".mpeg"     . "video/mpeg")
  918.     (".mpega"    . "audio/x-mpeg")
  919.     (".mpegv"    . "video/mpeg")
  920.     (".mpg"      . "video/mpeg")
  921.     (".mpv"      . "video/mpeg")
  922.     (".ms"       . "application/x-troff-ms")
  923.     (".nc"       . "application/x-netcdf")
  924.     (".nc"       . "application/x-netcdf")
  925.     (".oda"      . "application/oda")
  926.     (".pbm"      . "image/x-portable-bitmap")
  927.     (".pdf"      . "application/pdf")
  928.     (".pgm"      . "image/portable-graymap")
  929.     (".pict"     . "image/pict")
  930.     (".png"      . "image/png")
  931.     (".pnm"      . "image/x-portable-anymap")
  932.     (".ppm"      . "image/portable-pixmap")
  933.     (".ps"       . "application/postscript")
  934.     (".qt"       . "video/quicktime")
  935.     (".ras"      . "image/x-raster")
  936.     (".rgb"      . "image/x-rgb")
  937.     (".rtf"      . "application/rtf")
  938.     (".rtx"      . "text/richtext")
  939.     (".sh"       . "application/x-sh")
  940.     (".sit"      . "application/x-stuffit")
  941.     (".snd"      . "audio/basic")
  942.     (".src"      . "application/x-wais-source")
  943.     (".tar"      . "archive/tar")
  944.     (".tcl"      . "application/x-tcl")
  945.     (".tcl"      . "application/x-tcl")
  946.     (".tex"      . "application/x-tex")
  947.     (".texi"     . "application/texinfo")
  948.     (".tga"      . "image/x-targa")
  949.     (".tif"      . "image/tiff")
  950.     (".tiff"     . "image/tiff")
  951.     (".tr"       . "application/x-troff")
  952.     (".troff"    . "application/x-troff")
  953.     (".tsv"      . "text/tab-separated-values")
  954.     (".txt"      . "text/plain")
  955.     (".vbs"      . "video/mpeg")
  956.     (".vox"      . "audio/basic")
  957.     (".vrml"     . "x-world/x-vrml")
  958.     (".wav"      . "audio/x-wav")
  959.     (".wrl"      . "x-world/x-vrml")
  960.     (".xbm"      . "image/xbm")
  961.     (".xpm"      . "image/x-pixmap")
  962.     (".xwd"      . "image/windowdump")
  963.     (".zip"      . "application/zip")
  964.     (".ai"       . "application/postscript")
  965.     (".jpe"      . "image/jpeg")
  966.     (".jpeg"     . "image/jpeg")
  967.     )
  968.   "*An assoc list of file extensions and the MIME content-types they
  969. correspond to.")
  970.  
  971. (defun mm-parse-mimetypes (&optional path)
  972.   ;; Parse out all the mimetypes specified in a unix-style path string PATH
  973.   (cond
  974.    (path nil)
  975.    ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES")))
  976.    ((memq system-type '(ms-dos ms-windows windows-nt))
  977.     (setq path (mapconcat 'expand-file-name
  978.               '("~/mime.typ" "~/etc/mime.typ") ";")))
  979.    (t (setq path (mapconcat 'expand-file-name
  980.                 '("~/.mime-types"
  981.                   "/etc/mime-types:/usr/etc/mime-types"
  982.                   "/usr/local/etc/mime-types"
  983.                   "/usr/local/www/conf/mime-types") ":"))))
  984.   (let ((fnames (reverse
  985.          (mm-string-to-tokens path
  986.                       (if (memq system-type
  987.                         '(ms-dos ms-windows windows-nt))
  988.                       ?;
  989.                     ?:))))
  990.     fname)
  991.     (while fnames
  992.       (setq fname (car fnames))
  993.       (if (and (file-exists-p fname) (file-readable-p fname))
  994.       (mm-parse-mimetype-file (car fnames)))
  995.       (setq fnames (cdr fnames)))))
  996.  
  997. (defun mm-parse-mimetype-file (fname)
  998.   ;; Parse out a mime-types file
  999.   (let (type                ; The MIME type for this line
  1000.     extns                ; The extensions for this line
  1001.     save-pos            ; Misc. saved buffer positions
  1002.     )
  1003.     (save-excursion
  1004.       (set-buffer (get-buffer-create " *mime-types*"))
  1005.       (erase-buffer)
  1006.       (insert-file-contents fname)
  1007.       (mm-replace-regexp "#.*" "")
  1008.       (mm-replace-regexp "\n+" "\n")
  1009.       (mm-replace-regexp "[ \t]+$" "")
  1010.       (goto-char (point-max))
  1011.       (skip-chars-backward " \t\n")
  1012.       (delete-region (point) (point-max))
  1013.       (goto-char (point-min))
  1014.       (while (not (eobp))
  1015.     (skip-chars-forward " \t\n")
  1016.     (setq save-pos (point))
  1017.     (skip-chars-forward "^ \t")
  1018.     (downcase-region save-pos (point))
  1019.     (setq type (buffer-substring save-pos (point)))
  1020.     (while (not (eolp))
  1021.       (skip-chars-forward " \t")
  1022.       (setq save-pos (point))
  1023.       (skip-chars-forward "^ \t\n")
  1024.       (setq extns (cons (buffer-substring save-pos (point)) extns)))
  1025.     (while extns
  1026.       (setq mm-mime-extensions
  1027.         (cons
  1028.          (cons (if (= (string-to-char (car extns)) ?.)
  1029.                (car extns)
  1030.              (concat "." (car extns))) type) mm-mime-extensions)
  1031.         extns (cdr extns)))))))
  1032.  
  1033. (defun mm-extension-to-mime (extn)
  1034.   "Return the MIME content type of the file extensions EXTN"
  1035.   (if (and (stringp extn)
  1036.        (not (eq (string-to-char extn) ?.)))
  1037.       (setq extn (concat "." extn)))
  1038.   (cdr (assoc (downcase extn) mm-mime-extensions)))
  1039.  
  1040.  
  1041. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1042. ;;; Editing/Composition of body parts
  1043. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1044. (defun mm-compose-type (type)
  1045.   ;; Compose a body section of MIME-type TYPE.
  1046.   (let* ((info (mm-mime-info type nil 5))
  1047.      (fnam (mm-generate-unique-filename))
  1048.      (comp (or (cdr (assoc "compose" info))))
  1049.      (ctyp (cdr (assoc "composetyped" info)))
  1050.      (buff (get-buffer-create " *mimecompose*"))
  1051.      (typeit (not ctyp))
  1052.      (retval "")
  1053.      (usef nil))
  1054.     (setq comp (mm-unescape-mime-test (or comp ctyp) info))
  1055.     (while (string-match "\\([^\\\\]\\)%s" comp)
  1056.       (setq comp (concat (substring comp 0 (match-end 1)) fnam
  1057.              (substring comp (match-end 0) nil))
  1058.         usef t))
  1059.     (call-process shell-file-name nil
  1060.           (if usef nil buff)
  1061.           nil shell-command-switch comp)
  1062.     (setq retval
  1063.       (concat
  1064.        (if typeit (concat "Content-type: " type "\r\n\r\n") "")
  1065.        (if usef
  1066.            (save-excursion
  1067.          (set-buffer buff)
  1068.          (erase-buffer)
  1069.          (insert-file-contents fnam)
  1070.          (buffer-string))
  1071.          (save-excursion
  1072.            (set-buffer buff)
  1073.            (buffer-string)))
  1074.        "\r\n"))
  1075.     retval))    
  1076.  
  1077. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1078. ;;; Misc.
  1079. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1080. (defun mm-type-to-file (type)
  1081.   "Return the file extension for content-type TYPE"
  1082.   (rassoc type mm-mime-extensions))
  1083.  
  1084.  
  1085. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1086. ;;; Miscellaneous MIME viewers written in elisp
  1087. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1088. (defun mm-play-sound-file (&optional buff)
  1089.   "Play a sound file in buffer BUFF (defaults to current buffer)"
  1090.   (setq buff (or buff (current-buffer)))
  1091.   (let ((fname (mm-generate-unique-filename "%s.au"))
  1092.     (synchronous-sounds t))        ; Play synchronously
  1093.     (mule-write-region-no-coding-system (point-min) (point-max) fname)
  1094.     (kill-buffer (current-buffer))
  1095.     (play-sound-file fname)
  1096.     (condition-case ()
  1097.     (delete-file fname)
  1098.       (error nil))))
  1099.     
  1100. (defun mm-parse-mime-headers (&optional no-delete)
  1101.   "Return a list of the MIME headers at the top of this buffer.  If
  1102. optional argument NO-DELETE is non-nil, don't delete the headers."
  1103.   (let* ((st (point-min))
  1104.      (nd (progn
  1105.            (goto-char (point-min))
  1106.            (skip-chars-forward " \t\n")
  1107.            (if (re-search-forward "^\r*$" nil t)
  1108.            (1+ (point))
  1109.          (point-max))))
  1110.      save-pos
  1111.      status
  1112.      hname
  1113.      hvalu
  1114.      result
  1115.      )
  1116.     (narrow-to-region st nd)
  1117.     (goto-char (point-min))
  1118.     (while (not (eobp))
  1119.       (skip-chars-forward " \t\n\r")
  1120.       (setq save-pos (point))
  1121.       (skip-chars-forward "^:\n\r")
  1122.       (downcase-region save-pos (point))
  1123.       (setq hname (buffer-substring save-pos (point)))
  1124.       (skip-chars-forward ": \t ")
  1125.       (setq save-pos (point))
  1126.       (skip-chars-forward "^\n\r")
  1127.       (setq hvalu (buffer-substring save-pos (point))
  1128.         result (cons (cons hname hvalu) result)))
  1129.     (or no-delete (delete-region st nd))
  1130.     result))
  1131.  
  1132. (defun mm-find-available-multiparts (separator &optional buf)
  1133.   "Return a list of mime-headers for the various body parts of a 
  1134. multipart message in buffer BUF with separator SEPARATOR.
  1135. The different multipart specs are put in `mm-temporary-directory'."
  1136.   (let ((sep (concat "^--" separator "\r*$"))
  1137.     headers
  1138.     fname
  1139.     results)
  1140.     (save-excursion
  1141.       (and buf (set-buffer buf))
  1142.       (goto-char (point-min))
  1143.       (while (re-search-forward sep nil t)
  1144.     (let ((st (set-marker (make-marker)
  1145.                   (progn
  1146.                 (forward-line 1)
  1147.                 (beginning-of-line)
  1148.                 (point))))
  1149.           (nd (set-marker (make-marker)
  1150.                   (if (re-search-forward sep nil t)
  1151.                   (1- (match-beginning 0))
  1152.                 (point-max)))))
  1153.       (narrow-to-region st nd)
  1154.       (goto-char st)
  1155.       (if (looking-at "^\r*$")
  1156.           (insert "Content-type: text/plain\n"
  1157.               "Content-length: " (int-to-string (- nd st)) "\n"))
  1158.       (setq headers (mm-parse-mime-headers)
  1159.         fname (mm-generate-unique-filename))
  1160.       (let ((x (or (cdr (assoc "content-type" headers)) "text/plain")))
  1161.         (if (string-match "name=\"*\\([^ \"]+\\)\"*" x)
  1162.         (setq fname (expand-file-name
  1163.                  (substring x (match-beginning 1)
  1164.                     (match-end 1))
  1165.                  mm-temporary-directory))))
  1166.       (widen)
  1167.       (if (assoc "content-transfer-encoding" headers)
  1168.           (let ((coding (cdr
  1169.                  (assoc "content-transfer-encoding" headers)))
  1170.             (cmd nil))
  1171.         (setq coding (and coding (downcase coding))
  1172.               cmd (or (cdr (assoc coding
  1173.                       mm-content-transfer-encodings))
  1174.                   (read-string
  1175.                    (concat "How shall I decode " coding "? ")
  1176.                    "cat")))
  1177.         (if (string= cmd "") (setq cmd "cat"))
  1178.         (if (stringp cmd)
  1179.             (shell-command-on-region st nd cmd t)
  1180.           (funcall cmd st nd))
  1181.         (or (eq cmd 'ignore) (set-marker nd (point)))))
  1182.       (write-region st nd fname nil 5)
  1183.       (delete-region st nd)
  1184.       (setq results (cons
  1185.              (cons
  1186.               (cons "mm-filename" fname) headers) results)))))
  1187.     results))
  1188.  
  1189. (defun mm-format-multipart-as-html (&optional buf type)
  1190.   (if buf (set-buffer buf))
  1191.   (let* ((boundary (if (string-match
  1192.             "boundary[ \t]*=[ \t\"]*\\([^ \"\t\n]+\\)"
  1193.             type)
  1194.                (regexp-quote
  1195.             (substring type (match-beginning 1) (match-end 1)))))
  1196.      (parts    (mm-find-available-multiparts boundary)))
  1197.     (erase-buffer)
  1198.     (insert "<html>\n"
  1199.         " <head>\n"
  1200.         "  <title>Multipart Message</title>\n"
  1201.         " </head>\n"
  1202.         " <body>\n"
  1203.         "   <h1> Multipart message encountered </h1>\n"
  1204.         "   <p> I have encountered a multipart MIME message.\n"
  1205.         "       The following parts have been detected.  Please\n"
  1206.         "       select which one you want to view.\n"
  1207.         "   </p>\n"
  1208.         "   <ul>\n"
  1209.         (mapconcat 
  1210.          (function (lambda (x)
  1211.              (concat "    <li> <a href=\"file:"
  1212.                  (cdr (assoc "mm-filename" x))
  1213.                  "\">"
  1214.                  (or (cdr (assoc "content-description" x)) "")
  1215.                  "--"
  1216.                  (or (cdr (assoc "content-type" x))
  1217.                      "unknown type")
  1218.                  "</a> </li>")))
  1219.          parts "\n")
  1220.         "   </ul>\n"
  1221.         " </body>\n"
  1222.         "</html>\n"
  1223.         "<!-- Automatically generated by MM v" mm-version "-->\n")))
  1224.  
  1225. (defun mm-multipart-viewer ()
  1226.   (mm-format-multipart-as-html
  1227.    (current-buffer)
  1228.    (cdr (assoc "content-type" url-current-mime-headers)))
  1229.   (let ((w3-working-buffer (current-buffer)))
  1230.     (w3-prepare-buffer)))
  1231.  
  1232. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1233. ;;; Transfer encodings we can decrypt automatically
  1234. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1235. (defun mm-decode-quoted-printable (&optional st nd)
  1236.   (interactive)
  1237.   (setq st (or st (point-min))
  1238.     nd (or nd (point-max)))
  1239.   (save-restriction
  1240.     (narrow-to-region st nd)
  1241.     (save-excursion
  1242.       (let ((buffer-read-only nil))
  1243.     (goto-char (point-min))
  1244.     (while (re-search-forward "=[0-9A-F][0-9A-F]" nil t)
  1245.       (replace-match 
  1246.        (char-to-string 
  1247.         (+
  1248.          (* 16 (mm-hex-char-to-integer 
  1249.             (char-after (1+ (match-beginning 0)))))
  1250.          (mm-hex-char-to-integer
  1251.           (char-after (1- (match-end 0))))))))))
  1252.     (goto-char (point-max))))
  1253.  
  1254. ;; Taken from hexl.el.
  1255. (defun mm-hex-char-to-integer (character)
  1256.   "Take a char and return its value as if it was a hex digit."
  1257.   (if (and (>= character ?0) (<= character ?9))
  1258.       (- character ?0)
  1259.     (let ((ch (logior character 32)))
  1260.       (if (and (>= ch ?a) (<= ch ?f))
  1261.       (- ch (- ?a 10))
  1262.     (error (format "Invalid hex digit `%c'." ch))))))
  1263.  
  1264.  
  1265. (require 'base64)
  1266. (provide 'mm)
  1267.